Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/demostuf/magnify1.pas

Pascal/Delphi Source File | 1994-07-25 | 5.9 KB | 342 lines

program magnify_glass;
{ MAGNIFY GLASS #1
  - by Bjarke Viksφe
  jan 1994 (before I even got my PC, really)

  THIS PROGRAM WAS CODED BY BJARKE VIKS0E.
  YOU ARE FREE TO DO WHATEVER YOU WANT WITH THIS PIECE OF CODE.
  E-MAIL ME AT: [e-mail] IN 1994 FOR CHAT AND CODE.

  NB: doesn't really work in protected-mode... go real-mode instead!
}

const
    width = 320;

type
    screenpointer = ^screentype;
    screentype = array [0..65530] of byte;

var
   stackseg            : integer;
   oldmode, oldpage : shortint;
   i, j             : integer;
   xtabel           : array [0..319] of integer;
   ytabel           : array [0..255] of integer;

   ztabel            : array [0..64] of integer;
   matrix            : array [-32..31, -32..31] of integer;
   buffer            : array [0..63, 0..63] of byte;

    xpos, ypos, xadd, yadd : word;
    xpostabel        : array [0..255] of integer;
    ypostabel        : array [0..255] of integer;

    x,y, oldx, oldy    : integer;
    screenptr        : screenpointer;


(*-----------------------------------------------------------*)

procedure VBLANK;
begin
     asm
     mov     dx,$3DA
@vent1:
     in      al,dx
     test    al,8
     jz      @vent1
{@vent2:
     in      al,dx
     test    al,8
     jnz     @vent2}
     end;
end;


(*-----------------------------------------------------------*)

procedure SetColor(nr : integer; r,g,b : byte);
begin
     asm
     mov    bx,nr
     mov    cl,r
     mov    ch,g
     mov    dh,b
     mov    ax,$1010
     int    $10
     end;
end;

procedure OpenScreen;
var
   i, color : integer;
begin
    asm
    mov     ah,$0F
    int     $10
     mov     oldmode,al

    mov     al,$13
    xor     ah,ah
    int     $10
    end;

    color := 0;
    for i:=1 to 63 do
    begin
         SetColor(i, color,color,color);
         inc(color);
    end;
    for i:=64 to 127 do
    begin
         SetColor(i, color,color,color);
         dec(color);
    end;
end;

procedure CloseScreen;
begin
     asm
     mov    al,oldmode
     xor    ah,ah
     int    $10
     end;
end;

(*-----------------------------------------------------------*)

procedure MakePattern(value : byte);
var
    ytaller : integer;
begin
    ytaller := 200;
    asm
    mov     ax,$A000
    mov     es,ax
    mov     si,0

    mov     cl,value
    mov        ch,127
@yloop:
    mov     dl,160
    lea     di,xtabel
@xloop1:
    mov     bx,WORD PTR ytabel
    add     bx,[di]
    mov     ax,bx
    shr     ax,cl
    and     al,ch
    mov     [es:si],al
    inc     si
    inc     di
    inc     di

@xloop2:
    mov     bx,WORD PTR ytabel
    add     bx,[di]
    mov     ax,bx
    shr     ax,cl
    and     al,ch
    mov     [es:si],al
    inc     si
    inc     di
    inc     di
    dec     dl
    jnz     @xloop1

    add     WORD PTR @xloop1+2,2
    add     WORD PTR @xloop2+2,2
    dec     ytaller
    jnz     @yloop

    lea     si,ytabel
    mov     WORD PTR @xloop1+2, si
    mov     WORD PTR @xloop2+2, si
    end;
end;


(*-----------------------------------------------------------*)

procedure CalcMatrix;
var
    x,y,z : longint;
    tx,ty : longint;
begin
    for y:=-32 to 31 do
    begin
        for x:=-32 to 31 do
        begin
            z := round(sqrt(sqr(x*2)+sqr(y*2)));
            z := ztabel[z shr 1];
            tx := (x*z) DIV 2300;
            ty := (y*z) DIV 2300;
            matrix[y,x] := (ty*320)+tx;
        end;
    end;
end;


(*-----------------------------------------------------------*)

procedure CopyScreen;
begin
    asm
    push    ds
    mov        ax,WORD PTR screenptr+2
    mov        di,WORD PTR screenptr
    mov        es,ax
    mov        ax,$A000
    mov        ds,ax
    xor        si,si
    cld
    mov        cx,64000
    rep movsb
    pop        ds
    end;
end;


(*-----------------------------------------------------------*)

procedure SetupDemo;
var
    i : integer;
    v, vadd : real;
begin
     for i:=0 to 319 do
         xtabel[i]:=sqr(i-160);
     for i:=0 to 199 do
         ytabel[i]:=sqr(i-100);

    v:=0.0;
    vadd:=(2.0*pi/256.0);
    for i:=0 to 255 do
    begin
        xpostabel[i]:=round(sin(v)*110)+160;
        v:=v+vadd;
    end;
    v:=0.0;
    vadd:=(2.0*pi/256.0);
    for i:=0 to 255 do
    begin
        ypostabel[i]:=round(sin(v)*50)+100;
        v:=v+vadd;
    end;

    v:=pi/2.0;
    vadd:=(pi/2.0)/64.0;
    for i:=0 to 64 do
    begin
        ztabel[i]:=round(sin(v)*2500);
        v:=v+vadd;
    end;
    CalcMatrix;
    MakePattern(4);
    CopyScreen;
end;

(*-----------------------------------------------------------*)

procedure CopyFrombuffer(x,y : integer);
begin
    asm
    push    ds
    mov        ax,y
    mov     dx,width
    mul        dx
    add        ax,x
    mov        di,ax
    mov        si,ax
    add        si,WORD PTR screenptr

    mov        ax,WORD PTR screenptr+2
    mov        ds,ax
    mov        ax,$A000
    mov        es,ax

    sub        si,(32*320)+32
    sub        di,(32*320)+32
    cld
    mov        ax,320-64
    mov        dx,64
@copy:
    mov        cx,64
    rep movsb
    add        si,ax
    add        di,ax
    dec        dx
    jnz        @copy

    pop        ds
    end;
end;


procedure PrintMagnifyGlass(x,y : integer);
begin
    asm
    mov        stackseg,ss
    mov        ax,y
    mov     dx,width
    mul        dx
    add        ax,x
    mov        dx,ax
    mov        di,ax
    sub        di,(64*320)+64

    mov        ax,$A000
    mov        es,ax

    lea        si,matrix
    mov        ax,WORD PTR screenptr+2
    add        di,WORD PTR screenptr
    mov        ss,ax
    mov        ah,64
@loop1:
    mov        cx,64
@loop2:
    mov        bx,[si]
    add        bx,dx
    mov        al,[ss:di]
    mov        [es:bx],al
    add        di,2
    add        si,2
    loop    @loop2

    add        di,640-128
    dec        ah
    jnz        @loop1
    mov        ss,stackseg
    end;
end;


(*-----------------------------------------------------------*)

begin
    new(screenptr);
    OpenScreen;
    SetupDemo;

    xpos :=40; ypos:=20;
    xadd :=2; yadd:=1;

    for i:=1 to 1600 do
    begin
        VBLANK;
        CopyFromBuffer(oldx,oldy);
        x := xpostabel[xpos mod 256];
        y := ypostabel[ypos mod 256];
        PrintMagnifyGlass(x,y);

        oldx := x; oldy := y;
        inc(xpos,xadd);
        inc(ypos,yadd);
    end;

    CloseScreen;
    dispose(screenptr);
end.